home *** CD-ROM | disk | FTP | other *** search
/ Garbo / Garbo.cdr / mac / hypercrd / xcmd / dxcmds34.sit / Dartmouth XCMD's 3.4.3 / card_2103.txt < prev    next >
Text File  |  1990-04-17  |  8KB  |  300 lines
  1. -- card: 2103 from stack: in.3
  2. -- bmap block id: 0
  3. -- flags: 4000
  4. -- background id: 3241
  5. -- name: ClipToPICT
  6. ----- HyperTalk script -----
  7. on Install
  8.   get ChooseTargetStack()
  9.   InstallResource XFCN,ClipToPICT,it
  10. end Install
  11.  
  12.  
  13. -- part 1 (button)
  14. -- low flags: 00
  15. -- high flags: A003
  16. -- rect: left=75 top=300 right=322 bottom=192
  17. -- title width / last selected line: 0
  18. -- icon id / first selected line: 0 / 0
  19. -- text alignment: 1
  20. -- font id: 0
  21. -- text size: 12
  22. -- style flags: 0
  23. -- line height: 16
  24. -- part name: ClipToPICT
  25. ----- HyperTalk script -----
  26. on mouseUp
  27.   put ClipToPICT()
  28. end mouseUp
  29.  
  30.  
  31.  
  32. -- part 2 (field)
  33. -- low flags: 81
  34. -- high flags: 2007
  35. -- rect: left=12 top=26 right=298 bottom=491
  36. -- title width / last selected line: 0
  37. -- icon id / first selected line: 0 / 0
  38. -- text alignment: 0
  39. -- font id: 22
  40. -- text size: 10
  41. -- style flags: 0
  42. -- line height: 13
  43. -- part name: Source
  44.  
  45.  
  46. -- part 4 (button)
  47. -- low flags: 00
  48. -- high flags: A003
  49. -- rect: left=299 top=300 right=322 bottom=438
  50. -- title width / last selected line: 0
  51. -- icon id / first selected line: 0 / 0
  52. -- text alignment: 1
  53. -- font id: 0
  54. -- text size: 12
  55. -- style flags: 0
  56. -- line height: 16
  57. -- part name: Show Pascal Source
  58. ----- HyperTalk script -----
  59. on mouseUp
  60.   set the visible of card field 1 to not the visible of card field 1
  61.   if the visible of card field 1 is true then
  62.     set the name of me to "Hide Pascal Source"
  63.   else set the name of me to "Show Pascal Source"
  64. end mouseUp
  65.  
  66.  
  67.  
  68. -- part contents for background part 16
  69. ----- text -----
  70. CLIPTOPICT XFCN version 1.6
  71. Kevin Calhoun
  72.  
  73. ClipToPICT creates a PICT resource from a picture you've copied to the clipboard and copies it to the current stack.  You can tell ClipToPICT what ID number you want the PICT resource to have or you can let it select an unused number for you.  If you choose a number that belongs to another PICT resource currently contained in your stack, the new picture will overwrite the old one.
  74.  
  75. You'll know when there's a picture on the clipboard by examining HyperCard's edit menu.  If the paste item says "Paste Picture," then there's a picture available for ClipToPICT to turn into a PICT resource.
  76.  
  77. As with other resource copiers, if you use ClipToPICT to copy a PICT into the Home stack, you may have to quit and relaunch HyperCard in order to use it.
  78.  
  79. INVOKING CLIPTOPICT
  80.  
  81. get ClipToPICT(<pictID>,<"pictName">)
  82.  
  83. result:  resourceID
  84.  
  85. Both parameters are optional.  If you don't pass a value for pictID, ClipToPICT will find an ID for the PICT resource that's not currently in use.  If you don't pass a value for pictName, the PICT resource will be unnamed.  If you pass a value for pictID or pictName that's already in use by another PICT resource in the current stack, the old PICT will be overwritten.
  86.  
  87. If the clipboard contains no pictures, or if there was a problem accessing the scrap, opening the current stack's resource file, or writing the resource, ClipToPICT will return an error message.  Word 1 of this message will be "Error."
  88.  
  89. EXAMPLES
  90.  
  91. put ClipToPICT(0,"The Little Engine That Could") into pictNumber
  92. get ClipToPICT(2880,"")
  93.  
  94. REVISION HISTORY
  95. 1.0 -- 4/22/88
  96. 1.5 -- 3/15/89  Altered source code for compatibility with MPW Pascal 3.0.  Also removed necessity of passing 0 as the PICT ID when you wanted ClipToPICT to select an unused ID.
  97. 1.6 -- 7/22/89  No longer leaves a NIL master pointer behind when replacing a resource.
  98.  
  99. -- part contents for card part 2
  100. ----- text -----
  101. UNIT ClipToPICTUnit;
  102.  
  103. { ClipToPICT XFCN ┬⌐ 1988-1989 by the Trustees of Dartmouth College }
  104. { Written by Kevin Calhoun }
  105.  
  106. { This source compatible with MPW Pascal 3.0 }
  107.  
  108. (*
  109. Pascal ClipToPICT.p
  110. Link -m ENTRYPOINT Γêé
  111.      -o "YourFile" Γêé
  112.      -rt XFCN=6465 Γêé
  113.      -sn Main=ClipToPICT Γêé
  114.      ClipToPICT.p.o Γêé
  115.     "{Libraries}"interface.o Γêé
  116.     "{PLibraries}"Paslib.o Γêé
  117.     "{Libraries}"HyperXLib.o
  118. *)
  119.  
  120. {$R-}
  121.  
  122. INTERFACE
  123.   USES
  124.     Types,
  125.     Memory,
  126.     Scrap,
  127.     ToolUtils,
  128.     Resources,
  129.     Errors,
  130.     HyperXCmd;
  131.  
  132.   PROCEDURE EntryPoint (paramPtr : XCMDPtr);
  133.  
  134. IMPLEMENTATION
  135.  
  136.   PROCEDURE GetPictScrap (paramPtr : XCMDPtr); FORWARD;
  137.  
  138.   PROCEDURE EntryPoint (paramPtr : XCMDPtr);
  139.   BEGIN
  140.     GetPictScrap(paramPtr);
  141.   END;
  142.  
  143.   FUNCTION GetTheNameOfThisStack (paramPtr : XCMDPtr; var str: Str255): OSErr;
  144.     VAR
  145.       theResult : Handle;
  146.       theLength : Longint;
  147.       err: OSErr;
  148.   BEGIN
  149.     err := noErr;
  150.     str := 'word 2 of the long name of this stack';
  151.     theResult := EvalExpr(paramPtr, str);
  152.     err := paramPtr^.result;
  153.     IF (theResult <> NIL) and (err = noErr) THEN
  154.       BEGIN
  155.       theLength := StringLength(paramPtr, theResult^);
  156.       ZeroToPas(paramPtr, theResult^, str);
  157.       DisposHandle(theResult);
  158.       DELETE(str,theLength,1);
  159.       DELETE(str,1,1);
  160.       END
  161.     ELSE str := '';
  162.     GetTheNameOfThisStack := err;
  163.   END;
  164.  
  165.   PROCEDURE GetPictScrap (paramPtr : XCMDPtr);
  166.     LABEL
  167.       99, 100;
  168.     VAR
  169.       parameterCount : INTEGER;
  170.       id : INTEGER;
  171.       name : Str255;
  172.       scrapLength : longint;
  173.       offset : longint;
  174.       thePicHandle : Handle;
  175.       str : Str255;
  176.       myStack, curFile : INTEGER;
  177.       resAlready : Handle;
  178.       gotID, gotName : BOOLEAN;
  179.       err: LONGINT;
  180.  
  181.     PROCEDURE PassReturnValue (theMsg : Str255); { set theResult and quit }
  182.     BEGIN
  183.       paramPtr^.returnValue := PasToZero(paramPtr, theMsg);
  184.     END;
  185.  
  186.     PROCEDURE GetParameters;
  187.     BEGIN
  188.       gotID := FALSE;
  189.       gotName := FALSE;
  190.       name := '';
  191.       IF parameterCount > 0 THEN
  192.         BEGIN
  193.         ZeroToPas(paramPtr, paramPtr^.params[1]^, str);
  194.         if LENGTH(str) > 0 THEN gotID := TRUE;
  195.         id := StrToNum(paramPtr, str);
  196.         IF parameterCount > 1 THEN
  197.           BEGIN
  198.           ZeroToPas(paramPtr, paramPtr^.params[2]^, name);
  199.           if LENGTH(name) > 0 THEN gotName := TRUE;
  200.           END;
  201.         END;
  202.     END;
  203.  
  204.     PROCEDURE CheckForSameTypeIDName;
  205.     BEGIN
  206.       SetResLoad(FALSE);
  207.       IF not gotID THEN
  208.         REPEAT
  209.           id := Unique1ID('PICT');
  210.         UNTIL id > 127
  211.       ELSE
  212.         REPEAT
  213.           resAlready := Get1Resource('PICT', id);
  214.           IF resAlready <> NIL THEN
  215.             BEGIN
  216.               RmveResource(resAlready);
  217.               DisposHandle(resAlready);
  218.             END;
  219.         UNTIL resAlready = NIL;
  220.  
  221.       IF gotName THEN
  222.         REPEAT
  223.           resAlready := Get1NamedResource('PICT', name);
  224.           IF resAlready <> NIL THEN
  225.             BEGIN
  226.               RmveResource(resAlready);
  227.               DisposHandle(resAlready);
  228.             END;
  229.         UNTIL resAlready = NIL;
  230.       SetResLoad(TRUE);
  231.     END;
  232.  
  233.   BEGIN
  234.     err := noErr;
  235.     parameterCount := paramPtr^.paramCount;
  236.     IF parameterCount > 2 THEN
  237.       PassReturnValue('ClipToPICT XFCN 1.6, 22 July 1989, ┬⌐1988-1989 Dartmouth College')
  238.     ELSE
  239.       BEGIN
  240.       GetParameters;
  241.       err := GetTheNameOfThisStack(paramPtr,str);
  242.       IF err <> noErr THEN GOTO 100;
  243.  
  244.       myStack := OpenResFile(str);
  245.       IF (myStack = -1) AND (ResError = eofErr) THEN
  246.         BEGIN
  247.         CreateResFile(str);
  248.         err := ResError;
  249.         IF err = noErr THEN
  250.           myStack := OpenResFile(str);
  251.         END;
  252.       IF (myStack <= 0) OR (err <> noErr) THEN GOTO 100;
  253.  
  254.       scrapLength := GetScrap(NIL, 'PICT', offset);
  255.       IF scrapLength < 0 THEN
  256.         BEGIN
  257.         err := scrapLength;
  258.         GOTO 100;
  259.         END;
  260.         
  261.       thePicHandle := NewHandle(0);
  262.       err := MemError;
  263.       IF (thePicHandle = NIL) or (err <> noErr) THEN GOTO 100;
  264.  
  265.       scrapLength := GetScrap(thePicHandle, 'PICT', offset);
  266.       IF scrapLength <= 0 THEN
  267.         BEGIN
  268.         err := scrapLength;
  269.         GOTO 99;
  270.         END;
  271.  
  272.       HNoPurge(thePicHandle);
  273.       curFile := CurResFile;
  274.       UseResFile(myStack);
  275.       CheckForSameTypeIDName;
  276.       AddResource(thePicHandle, 'PICT', id, name);
  277.       err := ResError;
  278.       IF err <> noErr THEN
  279.         BEGIN
  280.         DisposHandle(thePicHandle);
  281.         GOTO 99;
  282.         END;
  283.  
  284.       SetResAttrs(thePicHandle, resPurgeable + resChanged);
  285.       WriteResource(thePicHandle);
  286.       UpdateResFile(myStack);
  287.       ReleaseResource(thePicHandle);
  288.       NumToStr(paramPtr, id, str);
  289.       PassReturnValue(str);
  290.       
  291.       99: UseResFile(curFile);
  292.       100: IF err <> noErr THEN
  293.         BEGIN
  294.         NumToStr(paramPtr, err, str);
  295.         PassReturnValue(CONCAT('Error ', str));
  296.         END;
  297.       END;
  298.   END;
  299.  
  300. END.